home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
tcl
/
tclm_1_0.lha
/
tclm-1.0
/
infom
< prev
next >
Wrap
Text File
|
1993-08-16
|
7KB
|
241 lines
#!/usr/local/bin/tclm -f
#
# Copyright (c) 1993 Michael B. Durian. All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
# must display the following acknowledgement:
# This product includes software developed by Michael B. Durian.
# 4. The name of the the Author may be used to endorse or promote
# products derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# infom,v 1.2 1993/05/06 21:42:20 durian Exp
# get filename arg
if {[string compare [lindex $argv 0] "-f"] == 0} {
incr argc -2
set argv [lrange $argv 2 end]
}
case $argc in {
0 {
set infile_name stdin
set outfile_name stdout
} 1 {
set infile_name [lindex $argv 0]
set outfile_name stdout
} 2 {
set infile_name [lindex $argv 0]
set outfile_name [lindex $argv 1]
} default {
puts stderr "Usage: infom [info_file [midi_file]]"
exit 1
}
}
proc PutEvent {event mfile track_num last_timing} {
# get the timing part of the event
set timing [lindex $event 0]
# minus :
set timing [string trimright $timing :]
#determine time since last event
set delta [expr {$timing - $last_timing}]
case [lindex $event 1] in {
NOTEOFF {
set chan [lindex $event 3]
set pitch [lindex $event 5]
set vel [lindex $event 7]
midiput $mfile $track_num $delta noteoff $chan $pitch $vel
} NOTEON {
set chan [lindex $event 3]
set pitch [lindex $event 5]
set vel [lindex $event 7]
midiput $mfile $track_num $delta noteon $chan $pitch $vel
} KEY {
set chan [lindex $event 4]
set pitch [lindex $event 6]
set pres [lindex $event 8]
midiput $mfile $track_num $delta keypressure $chan $pitch $pres
} PARAMETER {
set chan [lindex $event 3]
set param [lindex $event 5]
set set [lindex $event 7]
midiput $mfile $track_num $delta parameter $chan $param $set
} PROGRAM {
set chan [lindex $event 3]
set prog [lindex $event 5]
midiput $mfile $track_num $delta program $chan $prog
} CHANNEL {
set chan [lindex $event 4]
set pres [lindex $event 6]
midiput $mfile $track_num $delta channelpressure $chan $pres
} PITCH {
set chan [lindex $event 4]
set val [lindex $event 6]
midiput $mfile $track_num $delta pitchwheel $chan $val
} METACHANPREFIX {
midiput $mfile $track_num $delta metachanprefix \
[lrange $event 2 end]
} METACPY {
midiput $mfile $track_num $delta metacpy [lrange $event 2 end]
} METACUE {
midiput $mfile $track_num $delta metacue [lrange $event 2 end]
} METAEOT {
midiput $mfile $track_num $delta metaeot
} METAINSTNAME {
midiput $mfile $track_num $delta metainstname \
[lrange $event 2 end]
} METAKEY {
midiput $mfile $track_num $delta metakey [lindex $event 2] \
[lindex $event 3]
} METALYRIC {
midiput $mfile $track_num $delta metalyric \
[lrange $event 2 end]
} METAMARKER {
midiput $mfile $track_num $delta metamarker \
[lrange $event 2 end]
} METASEQNAME {
midiput $mfile $track_num $delta metaseqname \
[lrange $event 2 end]
} METASEQNUM {
midiput $mfile $track_num $delta metaseqnum [lindex $event 2]
} METASEQSPEC {
# no idea, so we skip it
return $last_timing
} METASMPTE {
set hr [string trimright [lindex $event 3] ,]
set mi [string trimright [lindex $event 5] ,]
set se [string trimright [lindex $event 7] ,]
set fr [string trimright [lindex $event 9] ,]
set ff [lindex $event 12]
midiput $mfile $track_num $delta metasmpte $hr $mi $se $fr $ff
} METATEMPO {
midiput $mfile $track_num $delta metatempo [lindex $event 2]
} METATEXT {
midiput $mfile $track_num $delta metatext [lrange $event 2 end]
} METATIME {
set fraction [split [lindex $event 2] /]
set num [lindex $fraction 0]
set den [lindex $fraction 1]
set cpm [lindex $event 3]
set _32 [lindex $event 8]
midiput $mfile $track_num $delta metatime $num $den $cpm $_32
} SYSEX {
if {[string compare [lindex $event 2] cont] == 0} {
midiput $mfile $track_num $delta sysex cont \
[lrange $event 3 end]
} else {
midiput $mfile $track_num $delta sysex \
[lrange $event 2 end]
}
}
}
return $timing
}
if {[string compare $infile_name stdin] == 0} {
set infile stdin
} else {
if {![file exists $infile_name]} then {
puts stderr "Bad file name: $infile_name"
exit 1
} else {
set infile [open $infile_name "r"]
}
}
if {[string compare $outfile_name stdout] == 0} {
set outfile stdout
} else {
# check to see if the specified file exists and open it
if {[catch {open $outfile_name "w"} outfile]} {
puts stderr "Couldn't open $midi_file_name for writing"
puts stderr $outfile
}
}
# make an empty mfile
set mfile [midimake]
# skip over filename since we use the command line
if {[gets $infile line] == -1} {
puts stderr "bad input line: $junk"
exit 1
}
# get format
if {[gets $infile line] == -1} {
puts stderr "bad input line: $junk"
exit 1
}
set format [lindex $line 2]
midiconfig $mfile format $format
# get division
if {[gets $infile line] == -1} {
puts stderr "bad input line: $junk"
exit 1
}
set division [lindex $line 2]
midiconfig $mfile division $division
# get num_trks
if {[gets $infile line] == -1} {
puts stderr "bad input line: $junk"
exit 1
}
set num_trks [lindex $line 4]
midiconfig $mfile tracks $num_trks
# generate all the tracks
set track 0
while {1} {
if {[gets $infile line] == -1} {
if {[expr {$num_trks - 1}] != $track} {
puts stderr "bad input line: $junk"
exit 1
} else {
break
}
}
if {[string compare [lindex $line 0] Track] == 0} {
set timing 0
set track [lindex $line 1]
continue
}
if {[string length $line] == 0} {
continue
}
set timing [PutEvent $line $mfile $track $timing]
}
midiwrite $mfile $outfile
midifree $mfile
close $outfile
close $infile
exit 0